perm filename HOMX.F4[LLL,LCS] blob
sn#573328 filedate 1981-07-24 generic text, type T, neo UTF8
00100 C HOMX, LULOOP, ZCRSOR, HELP, ORDER, DPYX, FILX, RREAD, NUMZ
00200 C****** FOR 'HOMING' OF BEAMS AND CHORD NOTES ***********
00300 SUBROUTINE HOMX
00400 COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20) /RNW/RNW
00500 1 /POSI/STFF(0/7),JJ2,POS /LIMIT/LIMIT,ITEM,L,I,IX
00600 2 /STF/RSTFAC(0/7),RSTJ2 /XRN/RN(1) /PTR/PWDS(1)
00700 3 /ALF/QQ(3),K,RA,RB,N,RG,M,X,RE,RF,A,B,DISX,INP(58)
00750 4 /OLDTOP/OLDY
00800 EQUIVALENCE (R3,RJQ(1)),(R7,RJQ(5)),(R9,RJQ(7))
00900 1,(R4,RJQ(2)),(R8,RJQ(6)),(R5,RJQ(3)),(R10,RJQ(8))
01000
01100 JJ2=1000
01200 C THE STAFF # =R2
01300 DO 110 K=1,ITEM
01400 IF(CODN(K,L).NE.6)GO TO 110
01500 C RETURNS POINTER IN L
01600 C%%%%%%%%%%%
01700 IF(R2.GT.7)GO TO 10
01800 C J2=STAFF #. >7 = ALL STAVES.
01900 IF(RN(L+2).NE.R2)GO TO 110
02000 10 R7=RN(L+7)
02100 IF(R7)GO TO 110
02200 C SKIP TREMOLO AND UNATTACHED PARTIAL BEAMS.
02300 RS=RN(L+2)
02400 C STAFF OF THIS BEAM
02500 ISD=IFIX(R7/10.)
02600 C STEM DIRECTION. 1=UP 2=DOWN
02700 RM=RSTFAC(IFIX(RS))
02800 RSTJ2=RM
02900 C SIZE FACTOR
03000 RL=RN(L+3)
03100 RR=RN(L+6)
03200 C OVERALL LEFT-RIGHT LIMITS
03300 PL=RL
03400 PR=RR
03500 C LEFT-RIGHT POS. TO BE USED
03600 RLH=RN(L+4)
03700 RRH=RN(L+5)
03800 C LEFT-RIGHT HEIGHTS
03900 RMIN=1.
04000 MIN=-1
04100 C FLAG FOR MINI-NOTES AND BEAMS
04200 W=ABS(RLH)
04300 IF(W.LE.80)GO TO 20
04400 CCC IF(W.GE.180)GO TO 3
04500 C SKIP IF X NOTES, DIAMONDS, NO NOTE HEAD
04600 MIN=0
04700 RMIN=.6
04800 RM=RM*.6
04900 C MINI SIZE FACTOR
05000 RLH=ABS(RLH)-100.
05100 20 WC=RN(L)
05200 C WORD COUNT
05300 T=-1
05400 IF(RN(L+10).GE.100)GO TO 30
05500 C P10=100 ETC. =COMPOSITE BEAM WITH AT LEAST 1 COMPLETE ONE.
05600 IF(WC.LT.6)GO TO 30
05700 R8=RN(L+8)
05800 IF(R8.EQ.0)GO TO 30
05900 IF(R8)GO TO 110
06000 IF(WC.LT.7)GO TO 30
06100 R9=RN(L+9)
06200 IF(R9.EQ.0)GO TO 30
06300 PL=R8
06400 PR=R9
06500 C POS. OF INNER PARTIAL BEAM.
06600 IF(WC.LT.8)GO TO 30
06700 IF(RN(L+10).GT.0)T=RN(L+10)+T
06800 30 IR7=AMOD(R7,10.0)+T
06900 C NUMBER OF BEAMS
07000 PL=PL-.1
07100 PR=PR+.1
07200 C FOR ROUND-OFF ERROR
07300 T=RR-RL
07400 C TOTAL LENGTH OF FULL BEAM
07500 TH=RRH-RLH
07600 C TOTAL HEIGHT
07700 T=TH/T
07800 C FACTOR
07900
08000 DO 100 J=1,ITEM
08100 IF(CODN(J,L).NE.1)GO TO 100
08200 IF(RN(L+2).NE.RS)GO TO 100
08300 C SKIP IF NOT ON RIGHT STAFF
08400 R5=RN(L+5)
08500 IF(R5.LT.10)GO TO 100
08600 C SKIP IF NO STEM ON NOTE
08700 R3=RN(L+3)
08800 IXD=0
08900 CW A=0
09000 IF(IFIX(R5/10.).EQ.ISD)GO TO 40
09100 C A IS FOR HORZ. DISPLACEMENT DUE TO OPPOSITE STEM DIRECTIONS.
09200 IXD=-1
09300 A=RNW*RM
09400 C A=WIDTH OF NOTE*SIZE FACTOR + OR - RNW=WIDTH OF A NOTE(2.44)
09500 IF(ISD.EQ.1)A=-A
09600 R3=A+R3
09700 40 IF(R3.LT.PL)GO TO 100
09800 IF(R3.GT.PR)GO TO 100
09900 C SKIP IF NOT IN BOUNDS OF BEAM SEGMENT.
10000 CW R3=A+R3
10100 R4=RN(L+4)
10200 R4X=ABS(R4)
10300 R4=AMOD(R4,100.0)
10400 IF(R4X.LE.80)GO TO 50
10500 IF(R4X.GE.180)GO TO 50
10600 IF(MIN)GO TO 100
10700 C NOW MINI-NOTE
10800 CC R4=ABS(R4)-100.
10900 IF(R4.GT.80.)R4=R4-100.
11000 C MINIS MAY GO FROM 81 TO 179. NUMS < 100 ARE CONVERTED TO NUM-100.
11100 GO TO 60
11200 50 IF(MIN.EQ.0)GO TO 100
11300 CC R4=AMOD(R4,100.0)
11400 CATCH DIAMONDS, X NOTES, HEADLESS NOTES.
11500 60 R6=T*(R3-RL)
11600 R8=RLH+R6-R4
11700 C ADJUSTED STEM LENGTH
11800 IF(ISD.EQ.2)R8=-R8
11900 IF(IXD.EQ.0)GO TO 70
12000 R9=(IR7*1.571429-13.714)*RMIN
12100 R8=-R8
12200 70 IF(RN(L).LT.8)GO TO 90
12300 CHECK P10 FOR STAFF CHANGE FLAG
12400 R10=RN(L+10)
12500 IF(R10.LE.0)GO TO 90
12600 N=-1
12700 IF(R10.EQ.2)N=-N
12800 C N =-1 = ON STAFF BELOW, =1 = ABOVE.
12900 M=RS
13000 R3=ABS((STFF(M+N)-STFF(M))/(RSTJ2*7))
13100 IF(IXD)GO TO 80
13200 IF(R10.NE.ISD)R3=-R3
13300 C ABOVE FOR STEMS SAME DIR, STAFF CHNG IN SAME DIR.
13400 80 R8=R8+R3
13500 C ADDS DISTANCE TO OTHER STAFF - CONVERTED TO NOTE NUMBERS.
13600 90 IF(IXD)R8=R8+R9
13700 C IF OPPOSITE STEM DIR., SUBTRACT (2*STEM AND EXTRA BEAM SPACE)*SIZE
13800 IF(R8.LT.-5)GO TO 100
13900 C AFTER ALL THAT, IF BEAM IS TOO SMALL THEN IGNORE IT.
14000 IF(JJ2.GT.J)JJ2=J
14100 C POINT TO 1ST ITEM TO RE-DISPLAY
14200 RN(L+8)=R8
14300 R7=RN(L+7)
14400 C NEXT DELETES TAILS
14500 IF(R7.EQ.0)GO TO 100
14600 N=AMOD(R7,10.)
14700 RN(L+7)=R7-N
14800 100 CONTINUE
14900 110 CONTINUE
15000 IF(JJ2.EQ.1000)JJ2=-1
15100 END
15200
15300 SUBROUTINE SHRINK(JIT)
15400 COMMON /XRN/RN(1) /PTR/KWDS(1) /LIMIT/LIMIT,ITEM,L,I,IX
15500 1 /ALF/A,B,C,K,M,N,MM
15600 IF(JIT.EQ.0)JIT=1
15700 MM=I
15800 DO 40 K=ITEM,JIT,-1
15900 L=KWDS(K)
16000 M=RN(L)
16100 IF(M.LE.2)GO TO 40
16200 J=M+2+L
16300 IF(RN(L+1).NE.1)GO TO 10
16400 IF(RN(L+8).EQ.0)RN(L+8)=999
16500 C NOTES MUST HAVE AT LEAST 8 PARAMS.
16600 10 DO 20 N=J,L,-1
16700 20 IF(RN(N).NE.0)GO TO 30
16800 GO TO 40
16900 30 IF(N.EQ.J)GO TO 40
17000 M=I-N
17100 CALL RLOOP(RN(N+1),RN(J+1),M)
17200 MM=J-N
17300 RN(L)=RN(L)-MM
17400 C RESET THE WDCNT.
17500 I=I-MM
17600 40 CONTINUE
17700 L=KWDS(JIT)
17800 50 JIT=JIT+1
17900 L=RN(L)+3+L
18000 C POINTER TO NEXT ITEM
18100 KWDS(JIT)=L
18200 IF(JIT.LE.ITEM)GO TO 50
18300 END
18400
18500 SUBROUTINE LULOOP
18600 COMMON /ALF/ INP(1)
18700 ICOM=0
18800 DO 10 K=1,72
18900 IF(ICOM.LT.0)INP(K)=' '
19000 J=INP(K)
19100 IF(J.NE.'<')GO TO 1
19200 INP(K)=' '
19300 ICOM=-1
19400 GO TO 10
19500 C USE '<' FOR COMMENTS. IGNORES REST OF LINE.
19600 1 IF(J.EQ.' ')GO TO 10
19700 INP(K)=J.AND..NOT.((J/2).AND."201004020100)
19800 10 CONTINUE
19900 END
20000
20100 SUBROUTINE ZCRSOR
20200 COMMON R2,JA,CENTR,J2,R3,R4,J,K,L,M
20300 DATA X/0.12/,Y/0.13/,Z/0.06/
20400 CC DATA X/1.2/,Y/1.3/
20500 CALL SETCUR(0,-300,0)
20600 IF(R2.NE.0)GO TO 20
20700 CC IF(R2.LT.99)GO TO 2
20800 CALL TYPSTR('<CR> SETS LOWER-LEFT POINT')
20900 ACCEPT 30,L
21000 CALL RDCUR(JA,J2)
21100 CALL TYPSTR('<CR> SETS UPPER-RIGHT POINT')
21200 ACCEPT 30,L
21300 CALL RDCUR(J,K)
21400 L=J-JA
21500 M=K-J2
21600 IF(L.GE.M)GO TO 10
21700 C ADD AND SUBTR. X COORDS. (MAKE THEM SAME DIST. AS Y'S)
21800 M=(M-L)/2
21900 J=J+M
22000 JA=JA-M
22100 10 L=J-JA
22200 R2=950.0/L
22300 JA=JA+L/2
22400 J2=J2+(K-J2)/2
22500 GO TO 40
22600 20 CALL TYPSTR('<CR> SETS CENTER')
22700 ACCEPT 30,L
22800 30 FORMAT(I)
22900 CALL RDCUR(JA,J2)
23000 40 CALL CLRCUR
23100 R3=JA*X+50.0
23200 R4=J2*Y+52.0
23300 K=0
23400 C (K IS R6) ↑↑↑↑↑ SO NUMS ON SPACING SCALE WILL PRINT.
23500 END
23600
23700 SUBROUTINE HELP(K)
23800 IMPLICIT INTEGER(A-Z)
23900 DIMENSION CDNUM(9)
24000 COMMON /DL/X22 /RRJJ/R(21),JJA /JCHAR/A,B,IBLA /RINP/I(16,8)
24100 1 /NUM/NUM(1)
24200 DATA CDNUM/'10','11','12','13','14','15','16','17','18'/
24300 L=-2
24400 C -2=DO LOOKUP ON MSS,MUS (HELP FILES 1→18.DMD)
24500 IF(K.NE.IBLA)GO TO 10
24600 IF(X22.EQ.0)RETURN
24700 C USE CURRENT CODE NUMBER IF IN EDIT MODE
24800 K=NUM(JJA+1)
24900 IF(JJA.GT.9)K=CDNUM(JJA-9)
25000 10 CALL GETFI2(K,L)
25100 IF(L.EQ.1)RETURN
25200 C L=1=FILE NOT FOUND
25300 L=-190
25400 CALL TYPLOC(450,L)
25500 20 CALL FASTI2(I,128)
25600 DO 40 K=1,8
25700 IF(I(1,K).EQ.999)GO TO 60
25800 DO 30 J=16,1,-1
25900 30 IF(I(J,K).NE.' ')GO TO 40
26000 J=1
26100 40 TYPE 50,(I(L,K),L=1,J)
26200 GO TO 20
26300 50 FORMAT(1X16A5/)
26400 60 CALL TYPCRLF
26500 END
26600
26700 SUBROUTINE ORDER
26800 IMPLICIT INTEGER(A-Q,S-Z)
26900 COMMON R2 /LIMIT/LIMIT,ITEM /ALF/I1
27000 1 /PTR/PWDS(1) /XRN/RN(1) /DPY/RST(1) /DPTR/WDS(1)
27100
27200 J=1
27300 CC J=4
27400 C J=4 SO FRONT OF DPY BUFFER IS UNTOUCHED.
27500 JJ=1
27600 DO 40 K=0,7
27700 10 M=0
27800 RX=9999.
27900 DO 20 L=1,ITEM
28000 N=PWDS(L)
28100 IF(R2.EQ.0.AND.K.NE.RN(N+2))GO TO 20
28200 C R2.EQ.0 = ORDER BY STAVES .NE.0 =ORDER ALL LEFT TO RIGHT
28300 R=RN(N+3)
28400 IF(R.EQ.10000.)GO TO 20
28500 C SKIP ITEM THAT WAS ALREADY SHUFFLED
28600 IF(RN(N+1).EQ.16)GO TO 30
28700 C DO NOT ORDER TEXT. (CODE 16)
28800 IF(R.GE.RX)GO TO 20
28900 RX=R
29000 M=L
29100 20 CONTINUE
29200 IF(M.EQ.0)GO TO 40
29300 C FOUND NO MORE ON THIS LINE
29400 L=M
29500 30 WDS(JJ)=J
29600 JJ=JJ+1
29700 C NOW PUT AWAY NEXT ITEM IN ORDER
29800 CC DO 3 MM=PWDS(L),PWDS(L+1)-1
29900 CC RST(J)=RN(MM)
30000 CC3 J=J+1
30100 MM=PWDS(L+1)-PWDS(L)
30200 C NEXT MOVES RN INTO RST
30300 CALL RLOOP(RST(J),RN(PWDS(L)),MM)
30400 J=J+MM
30500 RN(PWDS(L)+3)=10000.
30600 C WIPE OUT THIS POSITION
30700 GO TO 10
30800 40 CONTINUE
30900 CC DO 5 K=2,ITEM
31000 C NOW FIX UP POINTER ARRAY AGAIN
31100 CC5 PWDS(K)=WDS(K)-3
31200 C BECAUSE JJ STARTED AT =4
31300 CALL RLOOP(PWDS,WDS,ITEM)
31400 C PUTS WDS INTO PWDS
31500 CC DO 6 K=1,PWDS(ITEM+1)
31600 C AND RN ARRAY
31700 CC6 RN(K)=RST(K+3)
31800 CALL RLOOP(RN,RST,PWDS(ITEM+1))
31900 C PUT RST BACK INTO RN
32000 C SINCE DPY BUFFER WAS WIPED OUT, NOW DO A 'Z1' TO FIX IT UP.
32100 I1='Z'
32200 R2=1
32300 CALL DPYX
32400 END
32500
32600 SUBROUTINE DPYX
32700 C DOES COMPLETE DPY SETUP
32800 COMMON /DPY/ST(1)
32900 CALL DPYSET(1,ST,4000)
33000 CALL HYDPOG(2)
33100 CALL HYDPOG(1)
33200 CC CALL TYPLOC(450,0)
33300 CALL DPYBRT(5)
33400 END
33500
33600 SUBROUTINE FILX(K)
33700 C CHECKS TO SEE IF SOS OR ET FILE. IF SOS, REWRITES IT SANS #S.
33800 COMMON /ALF/I(72) /JCHAR/IXX,ISEMI,IBLA /A2Z/AA,BB,LCC,
33900 1 DD,EE,FF,GG,LHH,LII,LJJ,LKK,LEL,LMM,LNN,LOH /NUM/NZERO
34000 CALL IFILE(1,K)
34100 READ(1,50)I
34200 IF(I(1).EQ.NZERO)GO TO 70
34300 CXX **** FIX AT IRCAM 1/80 ***** IF(I(1).NE.LCC.AND.I(2).NE.LOH)GO TO 30
34400 IF(I(1).NE.LCC.OR.I(2).NE.LOH)GO TO 30
34500 C IF 1ST CHAR. IS ZERO, ASSUME IT'S AN SOS FILE
34600 C ASSUMES 'COMMENT' IF 1ST 2 CHARS ARE C AND O.
34700 20 READ(1,50)I
34800 IF(I(3).NE.ISEMI)GO TO 20
34900 C GET RID OF HEADER.
35000 READ(1,50)I
35100 C ONCE AGAIN!!
35200 RETURN
35300 30 READ(1,50,END=40)I
35400 GO TO 30
35500 C CLEAN EVERYTHING OUT.
35600 40 CALL IFILE(1,K)
35700 RETURN
35800 50 FORMAT(72A1)
35900 60 FORMAT(I,72A1)
36000 70 K='FOR21'
36100 CALL OFILE(21,K)
36200 REREAD 60,L,I
36300 CALL TYPSTR('SOS FILE COPIED TO FOR21.DAT')
36400 CALL TYPCRLF
36500 GO TO 90
36600 80 READ(1,60,END=100)L,I
36700 90 WRITE(21,50)I
36800 GO TO 80
36900 100 END FILE 21
37000 GO TO 40
37100 END
37200
37300 SUBROUTINE RREAD(I,V)
37400 C TAKES ASCII INPUT (INP) STRING, SEPARATES LETTERS FROM NUMBERS.
37500 C MAKES ALL NUMBS FLTING PT. FILLS UP END OF ARRAY WITH ZEROS.
37600 C SENDS BACK IN V ARRAY.
37700 C E.G. 'GET FOO 4.55' SENDS BACK V1=0, V2=0, V3=4.55, V4=0, ETC.
37800 DIMENSION I(1),V(1)
37900 EQUIVALENCE (N,RN)
38000 DO 62 J=1,50
38100 C ZERO V AND IV ARRAYS.****** 50 IS DIMENSION GIVEN IN MARKZ,BEAMS,SLURZ *********
38200 62 V(J)=0
38300 DO 6 LEND=71,1,-1
38400 6 IF(I(LEND).NE.' ')GO TO 7
38500 C LEND=END OF CHARS. STARTS WITH NEXT-TO-LAST (LAST IS *)
38600 RETURN
38700 9 IF(LETR.EQ.0)M=M+1
38800 LETR=-1
38900 GO TO 16
39000 7 M=1
39100 J=1
39200 LETR=0
39300 8 N=I(J)
39400 CALL LO2UP(N)
39500 IF(N.NE.' '.AND.N.NE.'/')GO TO 11
39600 C IGNORES BLANKS AND SLASHES
39700 LETR=0
39800 GO TO 16
39900 11 IF(N.EQ.'-')GO TO 16
40000 CX IF(N.NE.'F')GO TO 1
40100 C THIS IS FOR FINGERING NUMS. /3 F4/5 F1/ ETC.
40200 CX NN=I(J+1)
40300 CX IF(NN.GE.'0'.AND.NN.LE.'9')GO TO 9
40400 C CONSIDER 'F4' ETC. AS A UNIT.
40500 C IGNORE '-' (BUT LOOK IN NUMZ TO SEE IF JUST BEFORE A NUM.)
40600 C IF(N.NE.'-'.AND.
40700 C 1 N.NE.'.'.AND.(N.LT.'0'.OR.N.GT.'9'))GO TO 10
40800 CRR*** IF( N.NE.'.'.AND.(N.LT.'0'.OR.N.GT.'9'))GO TO 10
40900
41000 1 IF( N.NE.'.'.AND.(N.LT.'0'.OR.N.GT.'9'))GO TO 9
41100 C NOW IT'S A NUMBER
41200 20 CALL NUMZ(KK,I(J),V(M))
41300 J=J+KK-1
41400 CXX LETR=0
41500 C ABOVE IS NEW ON OCT. 1, 1980 *******
41600 10 M=M+1
41700 16 J=J+1
41800 IF(J.LE.LEND)GO TO 8
41900 END
42000
42100 SUBROUTINE NUMZ(KK,I,X)
42200 DIMENSION I(1)
42300 DATA IZERO/'0'/,ININE/'9'/
42400 J=-1
42500 M=0
42600 XMINUS=1.
42700 IF(I(0).EQ.'-')XMINUS=-XMINUS
42800 C I(0) MIGHT NOT WORK WITH SOME FORTRANS!!
42900 DO 21 KK=1,15
43000 C IS 15 ENOUGH? YES, WILL DO ONLY 8 DIGITS PLUS DECI.PT.
43100 IX=I(KK)
43200 IF(IX.GE.IZERO.AND.IX.LE.ININE)GO TO 22
43300 C IF(IX.EQ.'-')GO TO 24
43400 IF(IX.NE.'.')GO TO 20
43500 J=KK
43600 GO TO 21
43700 C 24 XMINUS=-XMINUS
43800 C GO TO 21
43900 22 N=(IX-IZERO)/536870912
44000 M=N+M*10
44100 21 CONTINUE
44200 20 IF(J.LT.0)GO TO 23
44300 X=KK-J-1
44400 X=XMINUS*M/(10.**X)
44500 RETURN
44600 23 X=XMINUS*M
44700 C FOR NO DECI.
44800 END
44900
45000 C**IRCAM** SUBROUTINE NUMLTR(L,J)
45100 C**IRCAM**C THIS, AND ABOVE ROUTINES, TAKES CARE OF STANFORD 'REREAD' FEATURE
45200 C**IRCAM**C 'RREAD' IS CALLED JUST AFTER ORIGINAL READ STATEMENT
45300 C**IRCAM** COMMON R2,JA,CEN,J2,RJQ(20) /SCM/V(22)
45400 C**IRCAM** J=V(1)
45500 C**IRCAM** N=L+1
45600 C**IRCAM** R2=V(N)
45700 C**IRCAM** DO 1 K=1,20
45800 C**IRCAM** 1 RJQ(K)=V(K+N)
45900 C**IRCAM** END